home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
PASCAL
/
1372.ZIP
/
PIBCAT.ARC
/
PIBCATS1.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-05-29
|
35KB
|
671 lines
(*--------------------------------------------------------------------------*)
(* Trim --- Trim trailing blanks from a string *)
(*--------------------------------------------------------------------------*)
FUNCTION Trim( S : AnyStr ) : AnyStr;
(*--------------------------------------------------------------------------*)
(* *)
(* Function: Trim *)
(* *)
(* Purpose: Trims trailing blanks from a string *)
(* *)
(* Calling sequence: *)
(* *)
(* Trimmed_S := TRIM( S ); *)
(* *)
(* S --- the string to be trimmed *)
(* Trimmed_S --- the trimmed version of S *)
(* *)
(* Calls: None *)
(* *)
(* Remarks: *)
(* *)
(* Note that the original string itself is left untrimmed. *)
(* *)
(* Pascal version might be written as: *)
(* *)
(* VAR *)
(* I: INTEGER; *)
(* *)
(* BEGIN *)
(* *)
(* I := ORD( S[0] ); *)
(* *)
(* WHILE ( I > 0 ) AND ( S[I] = ' ' ) DO *)
(* I := PRED( I ); *)
(* *)
(* S[0] := CHR( I ); *)
(* Trim := S; *)
(* *)
(* END; *)
(* *)
(*--------------------------------------------------------------------------*)
BEGIN (* Trim *)
INLINE(
$1E/ { PUSH DS ; Save DS}
{;}
$C5/$76/$06/ { LDS SI,[BP+6] ; Get address of S}
$FC/ { CLD ; Forward search}
$AC/ { LODSB ; Get length of S}
$3C/$00/ { CMP AL,0 ; See if length 0}
$74/$21/ { JE Trim2 ; If so, no trimming required}
{;}
$30/$ED/ { XOR CH,CH}
$88/$C1/ { MOV CL,AL ; Remember length for search loop}
{;}
$B0/$20/ { MOV AL,' ' ; Blank to AL}
{;}
$C4/$7E/$06/ { LES DI,[BP+6] ; Get address of S}
$01/$CF/ { ADD DI,CX ; Point to end of source string}
{;}
$FD/ { STD ; Backwards search}
$F3/$AE/ { REPE SCASB ; Scan over blanks}
$74/$01/ { JE Trim1 ; If CX=0, entire string is blank.}
$41/ { INC CX}
{;}
$88/$C8/ {Trim1: MOV AL,CL ; Length to copy}
$C5/$76/$06/ { LDS SI,[BP+6] ; Source string address}
$46/ { INC SI ; Skip length}
$C4/$7E/$0A/ { LES DI,[BP+10] ; Result string address}
$FC/ { CLD ; Forward move}
$AA/ { STOSB ; Set length in result}
$F2/$A4/ { REP MOVSB ; Move trimmed result}
$E9/$04/$00/ { JMP Exit}
{;}
$C4/$7E/$0A/ {Trim2: LES DI,[BP+10] ; Result string address}
$AA/ { STOSB ; Set length=0 in result}
{;}
$1F); {Exit: POP DS ; Restore DS}
END (* Trim *);
(*--------------------------------------------------------------------------*)
(* Dupl -- Duplicate a character n times *)
(*--------------------------------------------------------------------------*)
FUNCTION Dupl( Dup_char : Char; Dup_Count: INTEGER ) : AnyStr;
(*--------------------------------------------------------------------------*)
(* *)
(* Function: Dupl *)
(* *)
(* Purpose: Duplicate a character n times *)
(* *)
(* Calling Sequence: *)
(* *)
(* Dup_String := Dupl( Dup_Char: Char; Dup_Count: INTEGER ): AnyStr; *)
(* *)
(* Dup_Char --- Character to be duplicated *)
(* Dup_Count --- Number of times to duplicate character *)
(* Dup_String --- Resultant duplicated string *)
(* *)
(* Calls: None *)
(* *)
(* Remarks: *)
(* *)
(* This routine could be programmed directly in Turbo as: *)
(* *)
(* VAR *)
(* S : AnyStr; *)
(* *)
(* BEGIN *)
(* *)
(* FillChar( S[1], Dup_Count, Dup_Char ); *)
(* S[0] := CHR( Dup_Count ); *)
(* *)
(* Dupl := S; *)
(* *)
(* END; *)
(* *)
(*--------------------------------------------------------------------------*)
BEGIN (* Dupl *)
INLINE(
$8A/$4E/$06/ { MOV CL,[BP+6] ; Pick up dup count (0..255)}
$30/$ED/ { XOR CH,CH ; Clear upper byte of count}
$C4/$7E/$0A/ { LES DI,[BP+10] ; Result address}
$FC/ { CLD ; Set direction flag}
$88/$C8/ { MOV AL,CL ; Get result length}
$AA/ { STOSB ; Store result length}
$8B/$46/$08/ { MOV AX,[BP+8] ; Get char to duplicate}
$F2/$AA); { REP STOSB ; Perform duplication}
END (* Dupl *);
(*----------------------------------------------------------------------*)
(* Min --- Find minimum of two integers *)
(*----------------------------------------------------------------------*)
FUNCTION Min( A, B: INTEGER ) : INTEGER;
(*----------------------------------------------------------------------*)
(* *)
(* Function: Min *)
(* *)
(* Purpose: Returns smaller of two numbers *)
(* *)
(* Calling sequence: *)
(* *)
(* Smaller := MIN( A , B ) : INTEGER; *)
(* *)
(* A --- 1st input integer number *)
(* B --- 2nd input integer number *)
(* Smaller --- smaller of A, B returned *)
(* *)
(* *)
(* Calls: None *)
(* *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Min *)
IF A < B Then
Min := A
Else
Min := B;
END (* Min *);
(*----------------------------------------------------------------------*)
(* Max --- Find maximum of two integers *)
(*----------------------------------------------------------------------*)
FUNCTION Max( A, B: INTEGER ) : INTEGER;
(*----------------------------------------------------------------------*)
(* *)
(* Function: Max *)
(* *)
(* Purpose: Returns larger of two numbers *)
(* *)
(* Calling sequence: *)
(* *)
(* Larger := MAX( A , B ) : INTEGER; *)
(* *)
(* A --- 1st input integer number *)
(* B --- 2nd input integer number *)
(* Larger --- Larger of A, B returned *)
(* *)
(* *)
(* Calls: None *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Max *)
IF A > B Then
Max := A
Else
Max := B;
END (* Max *);
(*--------------------------------------------------------------------------*)
(* UpperCase --- Convert string to upper case *)
(*--------------------------------------------------------------------------*)
FUNCTION UpperCase( S: AnyStr ): AnyStr;
(*--------------------------------------------------------------------------*)
(* *)
(* Function: UpperCase *)
(* *)
(* Purpose: Convert string to upper case *)
(* *)
(* Calling Sequence: *)
(* *)
(* Upper_String := UpperCase( S : AnyStr ): AnyStr; *)
(* *)
(* S --- String to be converted to upper case *)
(* Upper_String --- Resultant uppercase string *)
(* *)
(* Calls: UpCase *)
(* *)
(* Remarks: *)
(* *)
(* This routine could be coded directly in Turbo as: *)
(* *)
(* VAR *)
(* I : INTEGER; *)
(* L : INTEGER; *)
(* T : AnyStr; *)
(* *)
(* BEGIN *)
(* *)
(* L := ORD( S[0] ); *)
(* *)
(* FOR I := 1 TO L DO *)
(* T[I] := UpCase( S[I] ); *)
(* *)
(* T[0] := CHR( L ); *)
(* UpperCase := T; *)
(* *)
(* END; *)
(* *)
(*--------------------------------------------------------------------------*)
BEGIN (* UpperCase *)
INLINE(
$1E/ { PUSH DS ; Save DS}
$C5/$76/$06/ { LDS SI,[BP+6] ; Get source string address}
$C4/$7E/$0A/ { LES DI,[BP+10] ; Get result string address}
$FC/ { CLD ; Forward direction for strings}
$AC/ { LODSB ; Get length of source string}
$AA/ { STOSB ; Copy to result string}
$30/$ED/ { XOR CH,CH}
$88/$C1/ { MOV CL,AL ; Move string length to CL}
$E3/$0E/ { JCXZ Exit ; Skip if null string}
{;}
$AC/ {UpCase1: LODSB ; Get next source character}
$3C/$61/ { CMP AL,'a' ; Check if lower-case letter}
$72/$06/ { JB UpCase2}
$3C/$7A/ { CMP AL,'z'}
$77/$02/ { JA UpCase2}
$2C/$20/ { SUB AL,'a'-'A' ; Convert to uppercase}
{;}
$AA/ {UpCase2: STOSB ; Store in result}
$E2/$F2/ { LOOP UpCase1}
{;}
$1F); {Exit: POP DS ; Restore DS}
END (* UpperCase *);
(*--------------------------------------------------------------------------*)
(* Get_Dos_Version --- Get MS DOS version number *)
(*--------------------------------------------------------------------------*)
FUNCTION Get_Dos_Version : INTEGER;
(*--------------------------------------------------------------------------*)
(* *)
(* Function: Get_Dos_Version *)
(* *)
(* Purpose: Returns current date in string form *)
(* *)
(* Calling sequence: *)
(* *)
(* Dos_Version := Get_Dos_Version: INTEGER; *)
(* *)
(* Dos_Version --- Returns MS DOS version in packed form *)
(* LO( Dos_Version ) = Major version number *)
(* HI( Dos_Version ) = Minor version number *)
(* *)
(* Calls: MsDos *)
(* *)
(*--------------------------------------------------------------------------*)
VAR
Regs: Registers;
BEGIN (* Get_Dos_Version *)
(* Get version number function *)
Regs.AX := $3000;
MsDos( Regs );
Get_Dos_Version := Regs.AX;
END (* Get_Dos_Version *);
(*--------------------------------------------------------------------------*)
(* Adjust_Hour --- Convert 24 hour time to 12 hour am/pm *)
(*--------------------------------------------------------------------------*)
PROCEDURE Adjust_Hour( VAR Hour : WORD;
VAR AmPm : STRING2 );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Adjust_Hour *)
(* *)
(* Purpose: Converts 24 hour time to 12 hour am/pm time *)
(* *)
(* Calling sequence: *)
(* *)
(* Adjust_Hour( VAR Hour : WORD; AmPm : String2 ); *)
(* *)
(* Hour --- Input = Hours in 24 hour form; *)
(* Output = Hours in 12 hour form. *)
(* AmPm --- Output 'am' or 'pm' indicator *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Adjust_Hour *)
IF ( Hour < 12 ) THEN
BEGIN
AmPm := 'am';
IF ( Hour = 0 ) THEN
Hour := 12;
END
ELSE
BEGIN
AmPm := 'pm';
IF ( Hour <> 12 ) THEN
Hour := Hour - 12;
END;
END (* Adjust_Hour *);
(*----------------------------------------------------------------------*)
(* Dir_Convert_Date_And_Time --- Convert directory creation date/time *)
(*----------------------------------------------------------------------*)
PROCEDURE Dir_Convert_Date_And_Time( Time : LONGINT;
VAR S_Date : AnyStr;
VAR S_Time : AnyStr );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Dir_Convert_Date_And_Time *)
(* *)
(* Purpose: Convert creation date/time from DOS directory entry. *)
(* *)
(* Calling Sequence: *)
(* *)
(* Dir_Convert_Date_And_Time( Time : LONGINT; *)
(* VAR S_Date : AnyStr; *)
(* VAR S_Time : AnyStr ); *)
(* *)
(* Time --- Packed time/date as read from DOS directory *)
(* S_Date --- converted date in dd-mon-yy format *)
(* S_Time --- converted time in hh:mm ampm format *)
(* *)
(* Calls: *)
(* *)
(* UnPackTime *)
(* *)
(*----------------------------------------------------------------------*)
VAR
DT : DateTime;
YY : String[2];
HH : String[2];
MM : String[3];
DD : String[2];
AmPm : STRING[2];
BEGIN (* Dir_Convert_Date *)
(* If time stamp is 0, don't bother *)
(* to unpack it. *)
IF ( Time = 0 ) THEN
BEGIN
S_Date := ' ';
S_Time := ' ';
END
ELSE
BEGIN
(* Get date/time values *)
UnpackTime( Time , DT );
WITH DT DO
BEGIN
STR( ( Year - 1900 ): 2 , YY );
MM := Month_Names[ Month ];
STR( Day:2 , DD );
S_Date := DD + '-' + MM + '-' + YY;
IF ( ( Hour + Min + Sec ) = 0 ) THEN
S_Time := ' '
ELSE
BEGIN
Adjust_Hour( WORD( Hour ) , AmPm );
STR( Hour:2 , HH );
STR( Min: 2 , MM );
IF ( MM[1] = ' ' ) THEN MM[1] := '0';
S_Time := HH + ':' + MM + ' ' + AmPm;
END;
END;
END;
END (* Dir_Convert_Date_And_Time *);
(*----------------------------------------------------------------------*)
(* Convert_String_To_AsciiZ -- Convert Turbo string to Ascii Z String *)
(*----------------------------------------------------------------------*)
PROCEDURE Convert_String_To_AsciiZ( VAR S: AnyStr );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Convert_String_To_AsciiZ *)
(* *)
(* Purpose: Convert Turbo string to ascii Z string *)
(* *)
(* Calling Sequence: *)
(* *)
(* Convert_String_To_AsciiZ( VAR S: AnyStr ); *)
(* *)
(* S --- Turbo string to be turned into Ascii Z string *)
(* *)
(* Calls: *)
(* *)
(* None *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Convert_String_To_AsciiZ *)
S := S + CHR( 0 );
END (* Convert_String_To_AsciiZ *);
(*----------------------------------------------------------------------*)
(* Dir_Set_Disk_Transfer_Address --- Set DMA address for disk I/O *)
(*----------------------------------------------------------------------*)
PROCEDURE Dir_Set_Disk_Transfer_Address( VAR DMA_Buffer );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Dir_Set_Disk_Transfer_Address *)
(* *)
(* Purpose: Sets DMA address for disk transfers *)
(* *)
(* Calling Sequence: *)
(* *)
(* Dir_Set_Disk_Transfer_Address( VAR DMA_Buffer ); *)
(* *)
(* DMA_Buffer --- direct memory access buffer *)
(* *)
(* Calls: *)
(* *)
(* MsDos *)
(* *)
(*----------------------------------------------------------------------*)
VAR
Dir_Reg: Registers;
BEGIN (* Dir_Set_Disk_Transfer_Address *)
Dir_Reg.Ax := $1A00;
Dir_Reg.Ds := SEG( DMA_Buffer );
Dir_Reg.Dx := OFS( DMA_Buffer );
MsDos( Dir_Reg );
END (* Dir_Set_Disk_Transfer_Address *);
(*----------------------------------------------------------------------*)
(* Dir_Get_Volume_Label --- Get volume label of a disk *)
(*----------------------------------------------------------------------*)
PROCEDURE Dir_Get_Volume_Label( Volume : CHAR;
VAR Volume_Label : AnyStr;
VAR Time : LONGINT );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Dir_Get_Volume_Label *)
(* *)
(* Purpose: Gets volume label for specified disk *)
(* *)
(* Calling sequence: *)
(* *)
(* Dir_Get_Volume_Label( Volume : CHAR; *)
(* VAR Volume_Label : AnyStr; *)
(* VAR Time : LONGINT ); *)
(* *)
(* Volume --- Disk letter for which to get label *)
(* Volume_Label --- Actual label itself *)
(* Time --- Packed creation date/time of volume label *)
(* *)
(* Remarks: *)
(* *)
(* Because of various bugs in the MS DOS 2.x file searching *)
(* facilities, this routine will not return a volume date or time *)
(* for DOS 2.x. *)
(* *)
(*----------------------------------------------------------------------*)
TYPE
Directory_Record = RECORD
Filler : ARRAY[1..21] Of BYTE;
File_Attr : BYTE (* File attributes *);
File_Time : LONGINT (* Creation time *);
File_Size : LONGINT (* Size in bytes *);
File_Name : ARRAY[1..80] Of CHAR (* Name *);
END;
Extended_FCB = RECORD
Fcb_Flag : BYTE (* $FF = extended FCB *);
Filler1 : ARRAY[1..5] OF BYTE;
FCB_Attr : BYTE (* File attribute *);
FCB_Drive : BYTE (* Drive *) ;
FCB_FileName: ARRAY[1..11] OF CHAR (* File name *);
FCB_BlockNo : INTEGER (* Block # *);
FCB_RecSize : INTEGER (* Record size *);
FCB_FileSize: Longint (* File size *);
FCB_Date : INTEGER (* File date *);
FCB_Time : INTEGER (* File time *);
Filler2 : ARRAY[1..33] OF BYTE (* Make 64 bytes *);
END;
(* File attribute values *)
CONST
Dir_Attr_Read_Only = 1;
Dir_Attr_Hidden = 2;
Dir_Attr_System = 4;
Dir_Attr_Volume_Label = 8;
Dir_Attr_Subdirectory = 16;
Dir_Attr_Archive = 32;
(* File access modes *)
Access_Read_Mode = 0;
Access_Write_Mode = 1;
Access_Read_And_Write_Mode = 2;
(* File attributes *)
Attribute_None = 0;
Attribute_Read_Only = 1;
Attribute_Hidden = 2;
Attribute_System = 4;
Attribute_Volume_Label = 8;
Attribute_Subdirectory = 16;
Attribute_Archive = 32;
VAR
Volume_Data : Directory_Record;
Regs : Registers;
Volume_Pat : STRING[15];
OVolume_Data : Extended_FCB;
Volume_FCB : Extended_FCB;
BEGIN (* Dir_Get_Volume_Label *)
(* Use FCB code for DOS 2.x *)
IF ( LO( Get_Dos_Version ) = 2 ) THEN
WITH Regs DO
BEGIN (* Dos 2.x *)
(* Clear out FCBs *)
FillChar( Volume_FCB , 64, 0 );
FillChar( OVolume_Data, 64, 0 );
(* Set up extended FCB for volume *)
(* label search. *)
Volume_FCB.FCB_Flag := $FF;
Volume_FCB.FCB_Attr := Attribute_Volume_Label;
Volume_FCB.FCB_Drive := ORD( Volume ) - ORD('A') + 1;
FillChar( Volume_FCB.FCB_FileName, 11, '?' );
(* Set address to receive volume label *)
Dir_Set_Disk_Transfer_Address( OVolume_Data );
(* Call DOS to search for volume label *)
Regs.Ds := SEG( Volume_FCB );
Regs.Dx := OFS( Volume_FCB );
Regs.Ax := $1100;
MsDos( Regs );
(* Check if we got label. If so, *)
(* get it. Date and time will most *)
(* likely be garbage, so set them to *)
(* zero so they won't be listed later. *)
IF ( Regs.Al = $FF ) THEN
Volume_Label := ''
ELSE
Volume_Label := OVolume_Data.FCB_FileName;
Time := 0;
END (* Dos 2.x *)
ELSE
WITH Regs DO
BEGIN (* Dos 3.x and higher *)
(* Set up DMA address for volume info *)
Dir_Set_Disk_Transfer_Address( Volume_Data );
(* Search root directory for label *)
Volume_Pat := Volume + ':*.*';
Convert_String_To_AsciiZ( Volume_Pat );
Regs.Ds := SEG( Volume_Pat[1] );
Regs.Dx := OFS( Volume_Pat[1] );
Regs.Ax := $4E00;
Regs.Cx := Attribute_Volume_Label;
(* Find volume label *)
MsDos( Regs );
IF ( FCarry AND Regs.Flags ) <> 0 THEN
BEGIN (* No volume label found *)
Volume_Label := '';
Time := 0;
END
ELSE
WITH Volume_Data DO
BEGIN (* Extract volume label *)
Volume_Label := TRIM( COPY( File_Name, 1, POS( #0 , File_Name ) - 1 ) );
Time := File_Time;
END;
END (* Dos 3.x and higher *);
END (* Dir_Get_Volume_Label *);
